VERSION 5.00
Begin VB.Form OEM4_TEST 
   Caption         =   "OEM4_TEST"
   ClientHeight    =   6480
   ClientLeft      =   60
   ClientTop       =   1590
   ClientWidth     =   8880
   LinkTopic       =   "Form1"
   ScaleHeight     =   6480
   ScaleWidth      =   8880
   Begin VB.CommandButton Cmd_SndStop 
      Caption         =   "停止发送"
      Height          =   375
      Left            =   7320
      TabIndex        =   7
      Top             =   5040
      Width           =   1095
   End
   Begin VB.CommandButton Cmd_RevStop 
      Caption         =   "停止接收"
      Height          =   375
      Left            =   7320
      TabIndex        =   6
      Top             =   4320
      Width           =   1095
   End
   Begin VB.Timer Timer_Send 
      Enabled         =   0   'False
      Left            =   1200
      Top             =   10800
   End
   Begin VB.Timer Timer_Recv 
      Enabled         =   0   'False
      Left            =   360
      Top             =   10800
   End
   Begin VB.CommandButton CmdExit 
      Caption         =   "退出"
      Height          =   375
      Left            =   7320
      TabIndex        =   5
      Top             =   5880
      Width           =   1095
   End
   Begin VB.CommandButton Cmd_OpenDev 
      Caption         =   "打开设备"
      Height          =   375
      Left            =   7320
      TabIndex        =   4
      Top             =   3480
      Width           =   1095
   End
   Begin VB.Frame Frame2 
      Caption         =   "发送窗口"
      Height          =   3135
      Left            =   0
      TabIndex        =   2
      Top             =   3240
      Width           =   6975
      Begin VB.TextBox TxtSend 
         BeginProperty DataFormat 
            Type            =   1
            Format          =   "12"
            HaveTrueFalseNull=   0
            FirstDayOfWeek  =   0
            FirstWeekOfYear =   0
            LCID            =   2052
            SubFormatType   =   0
         EndProperty
         Height          =   2775
         Left            =   120
         MultiLine       =   -1  'True
         ScrollBars      =   2  'Vertical
         TabIndex        =   3
         Top             =   240
         Width           =   6735
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "接收窗口"
      Height          =   3135
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   6975
      Begin VB.TextBox TxtRecv 
         Height          =   2775
         Left            =   120
         MultiLine       =   -1  'True
         ScrollBars      =   2  'Vertical
         TabIndex        =   1
         Top             =   240
         Width           =   6735
      End
   End
End
Attribute VB_Name = "OEM4_TEST"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function Open_PCIcard Lib "oem4pcidll.dll" (ByVal iIndex As Long) As Long
Private Declare Function Init_PCIcard Lib "oem4pcidll.dll" (ByVal iIndex As Long, ByRef init_addr As Byte, ByVal init_len As Byte) As Byte
Private Declare Sub Exit_PCIcard Lib "oem4pcidll.dll" (ByVal iIndex As Long)
Private Declare Function Recv_PBdata Lib "oem4pcidll.dll" (ByVal iIndex As Long, ByRef revda_addr As Byte, ByVal revda_len As Byte, ByRef revpda_addr As Byte, ByVal revpda_len As Byte) As Byte
Private Declare Function Send_PBdata Lib "oem4pcidll.dll" (ByVal iIndex As Long, ByRef sendda_addr As Byte, ByVal sendda_len As Byte) As Byte

Dim init_data(1 To 17) As Byte  '初始化数组
Dim recv_buf(1 To 48) As Byte   '接收数组
Dim prm_buf(1 To 48) As Byte    '参数数组
Dim send_buf(1 To 48) As Byte   '接收数组
Dim Snd_Cnt As Integer          '发送次数
Dim Rev_Cnt As Integer          '接收次数
Dim temp As Byte
Dim Rev_flag As Boolean         '接收标志
Dim Snd_flag As Boolean         '发送标志

'字符串显示函数，按照2位数字显示
Public Function TextOut(S As String, L As Integer, a As String) As String
  's   是要补位的字串符，l是你要的位数,a是你想要填补的符号
  Dim N     As Integer
  Dim STemp     As String
  N = Len(S)
  If N < L And N > 0 Then
    For t = 1 To L - N
      STemp = STemp & a
    Next t
  End If
  TextOut = STemp & S
  End Function
  
'停止接收
Private Sub Cmd_RevStop_Click()
    Rev_flag = Not Rev_flag
    
    Timer_Recv.Enabled = Rev_flag
    
    If Rev_flag Then
        Cmd_RevStop.Caption = "停止接收"
    Else
        Cmd_RevStop.Caption = "继续接收"
    End If
    
End Sub

'停止发送
Private Sub Cmd_SndStop_Click()
    Snd_flag = Not Snd_flag
    
    Timer_Send.Enabled = Snd_flag
    
    If Snd_flag Then
        Cmd_SndStop.Caption = "停止发送"
    Else
        Cmd_SndStop.Caption = "继续发送"
    End If

End Sub

'准备初始化数据
Private Sub Form_Load()

    init_data(1) = &H13
    init_data(2) = &H6
    init_data(3) = &HFA
    init_data(4) = &H6
    init_data(5) = &H1F
    init_data(6) = &H2F
    init_data(7) = &H1F
    init_data(8) = &H2F
    init_data(9) = &H1F
    init_data(10) = &H2F
    init_data(11) = 0
    init_data(12) = 0
    init_data(13) = 0
    init_data(14) = 0
    init_data(15) = 48
    init_data(16) = 48
    init_data(17) = 0
    Snd_Cnt = 0
    Rev_Cnt = 0
    Snd_flag = 1
    Rev_flag = 1
 
End Sub

'打开设备
Private Sub Cmd_OpenDev_Click()
    
    If (Open_PCIcard(0) = -1) Then      '打开设备失败
    
        MsgBox "无法打开PCI设备", MB_OK, "提示"
        End
    Else                                '打开成功后，初始化设备
        For k = 0 To 5                  '初始化设备5次，直至成功
            L = Init_PCIcard(0, init_data(1), 17)
            If L = &H10 Then
                L = 1
                Exit For
            Else
                L = 0
            End If
        Next k
        
        If L = 1 Then
            MsgBox "初始化成功", MB_OK, "提示"
            Timer_Recv.Interval = 100
            Timer_Send.Interval = 250
            Timer_Recv.Enabled = True
            Timer_Send.Enabled = True
        Else
            MsgBox "初始化失败", MB_OK, "提示"
            Exit_PCIcard (0)
            End
        End If
    End If
    

End Sub

'退出
Private Sub CmdExit_Click()
    Exit_PCIcard (0)
    End
End Sub

'定时器，连续接收
Private Sub Timer_Recv_Timer()
    Dim k As Byte
    Dim i As Byte
    
    If (Rev_Cnt Mod 15 = 0) Then
        TxtRecv.Text = ""
    End If
    
    k = Recv_PBdata(0, recv_buf(1), 48, prm_buf(1), 48) '接收PROFIBUS输入数据
    
    If (k = &H10) Then
        For k = 1 To 48
            TxtRecv.SelLength = Len(TxtRecv.Text)
            TxtRecv.SelText = TextOut(Hex(recv_buf(k)), 2, 0) + " "
        Next k
        TxtRecv.SelLength = Len(TxtRecv.Text)
        TxtRecv.SelText = Chr(13) + Chr(10)
        
        Rev_Cnt = Rev_Cnt + 1
    End If
    
    If (Rev_Cnt Mod 15 = 0) Then
        TxtRecv.Text = ""
    End If
        
End Sub

'定时器，连续发送
Private Sub Timer_Send_Timer()

    Dim k As Byte
    
    If (Snd_Cnt Mod 15 = 0) Then
        TxtSend.Text = ""
    End If
    
    For k = 1 To 48
        send_buf(k) = temp + k
        TxtSend.SelLength = Len(TxtSend.Text)
        TxtSend.SelText = TextOut(Hex(send_buf(k)), 2, 0) + " "
    Next k
    TxtSend.SelLength = Len(TxtSend.Text)
    TxtSend.SelText = Chr(13) + Chr(10)
    
    k = Send_PBdata(0, send_buf(1), 48) '发送PROFIBUS数据
    If temp = &HCF Then
        temp = 0
    End If
    
    temp = temp + 1

    Snd_Cnt = Snd_Cnt + 1

End Sub


